(library (match-definitions)
(export trie-merge compile-pattern interpret-tree)
(import (chezscheme))

(define (push-box! b v)
  (set-box! b (cons v (unbox b))))

(define (length=? l n)
  (if (null? l)
      (= n 0)
      (if (pair? l)
	  (length=? (cdr l) (- n 1))
	  #f)))

(define syntax-car
  (lambda (ls)
    (syntax-case ls ()
      ((x . y) #'x))))

(define syntax-cdr
  (lambda (ls)
    (syntax-case ls ()
      ((x . y) #'y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; This is the code for merging a list of instructions into a trie

(define terminator (cons '() '()))

(define (trie-merge seqs)
  (cond ((null? seqs)
	 '())
	((member '() seqs)
	 (cons terminator
               (trie-merge (filter pair? seqs))))
	(else (let* ((p (partition-by-head (caar seqs) seqs))
		     (tails (car p))
		     (rest (cdr p)))
		(cons `(,(caar seqs) . ,(trie-merge tails))
		      (trie-merge rest))))))

(define (partition-by-head head seqs)
  (cond ((null? seqs)
         terminator)
	(else (let* ((p (partition-by-head head (cdr seqs)))
 		     (l (car p))
 		     (r (cdr p)))
		(if (equal? (syntax->datum head)
			    (syntax->datum (caar seqs)))
		    (cons (cons (cdar seqs) l) r)
		    (cons l (cons (car seqs) r)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; This is the interpreter for trees of matching instructions.
;; matching instructions are as defined in compile-pattern,
;; and the trees terminate with an (execute <code>) command

;; The interpreter handles scope explicitly and manages a
;; fail continuation to do backtracking.

(define-syntax interpret-tree
  (syntax-rules (execute bind compare-equal? guard decons)

    ((interpret-tree scope () stack failure)
     failure)

    ((interpret-tree scope (((execute <body>) (())) <alternatives> ...) stack failure)
     (let* scope <body>))

    ((interpret-tree scope (((bind <var>) <then> ...) <alternatives> ...) stack failure)
     (let ((top (car stack))
           (new-stack (cdr stack)))
       (interpret-tree ((<var> top) . scope) (<then> ...) new-stack
		       (interpret-tree scope (<alternatives> ...) stack failure))))

    ((interpret-tree scope (((compare-equal? <s-expr>) <then> ...) <alternatives> ...)
                     stack failure)
     (let ((top (car stack))
           (new-stack (cdr stack)))
       (if (let* scope (equal? top <s-expr>))
           (interpret-tree scope (<then> ...) new-stack failure)
           (interpret-tree scope (<alternatives> ...) stack failure))))

    ((interpret-tree scope (((guard <predicate>) <then> ...) <alternatives> ...)
                     stack failure)
     (if (let* scope <predicate>)
         (interpret-tree scope (<then> ...) stack failure)
         (interpret-tree scope (<alternatives> ...) stack failure)))
    
    ((interpret-tree scope (((decons) <then> ...) <alternatives> ...) stack failure)
     (let ((top (car stack))
           (new-stack (cdr stack))
	   (fail-thunk (lambda ()
			 (interpret-tree scope (<alternatives> ...) stack failure))))
       (if (pair? top)
           (let ((stack (cons (car top) (cons (cdr top) new-stack))))
             (interpret-tree scope (<then> ...) stack (fail-thunk)))
	   (fail-thunk))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; This part compiles a pattern into a sequence of matching instructions
;; that performs the testing and binding operations
;;
;; Update this part to change or extend the pattern language.

;; <pat> ::= <var> | '<data> | `<qq>
;;                 | (list <pat> ...)
;;
;; <qq> ::= <atom> | ,<pat> | (<qq> . <qq>)

(define (identifier-mem? x ls)
  (and (not (null? ls))
       (or (bound-identifier=? x (car ls))
	   (identifier-mem? x (cdr ls)))))

(define (var? s) (symbol? (syntax->datum s)))
(define (atomic? s)
  (let ((s (syntax->datum s)))
    (or (null? s)
	(symbol? s) (number? s)
	(boolean? s) (string? s))))
(define (quoted? s)
  (let ((s (syntax->datum s)))
    (and (length=? s 2) (eq? 'quote (car s)))))
(define (quasiquoted? s)
  (let ((s (syntax->datum s)))
    (and (length=? s 2) (eq? 'quasiquote (car s)))))
(define (unquote? s)
  (let ((s (syntax->datum s)))
    (and (length=? s 2) (eq? 'unquote (car s)))))

(define (compile-pattern box pat rest)
  (cond ((var? pat) (compile-var box pat rest))
	((quoted? pat)
	 (let ((pat (syntax-car (syntax-cdr pat))))
	   (compile-quoted box pat rest)))
	((quasiquoted? pat)
	 (let ((pat (syntax-car (syntax-cdr pat))))
	   (compile-quasiquoted box pat rest)))
	(else (error 'compile-pattern "Invalid pattern" pat))))

(define (compile-var box var rest)
  (if (identifier-mem? var (unbox box))
      (cons #`(compare-equal? #,var) (rest))
      (begin
	(push-box! box var)
	(cons #`(bind #,var) (rest)))))

(define (compile-quoted box dat rest)
  (cons #`(compare-equal? '#,dat) (rest)))

(define (compile-quasiquoted box pat rest)
  (cond ((atomic? pat) (compile-quoted box pat rest))
	((unquote? pat) (compile-pattern box (syntax-car (syntax-cdr pat)) rest))
	(else (let ((x (syntax-car pat))
		    (y (syntax-cdr pat)))
		(cons #'(decons)
		      (compile-quasiquoted
		       box x
		       (lambda ()
			 (compile-quasiquoted
			  box y
			  rest))))))))

)

(library (match)
(export match)
(import (chezscheme) (match-definitions))

(define-syntax (match stx)
  (define (compile-pattern^ entry)
    (compile-pattern (box '())
		     (car entry)
		     (lambda ()
		       (list #`(execute #,(cadr entry))))))
  (syntax-case stx (else)
    ((match <exp> (<pattern> <body> ...) ... (else <fail> ...))
     (let* ((rules #'((<pattern> (begin <body> ...)) ...))
	    (instructions (map compile-pattern^ (syntax->list rules)))
	    (trie (trie-merge instructions)))
       #`(let ((stack (list <exp>)))
	   (interpret-tree ()
			   #,trie
			   stack
			   (begin <fail> ...)))))
    ((match <exp> (<pattern> <body> ...) ...)
     #'(match <exp> (<pattern> <body> ...) ... (else (error 'match "Failed to match"))))))

)
